home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / runtime / tuple-prims.scm < prev   
Encoding:
Text File  |  1994-09-27  |  2.1 KB  |  87 lines  |  [TEXT/CCL2]
  1. ;; these primitives support arbitrary sized tuples.
  2.  
  3. (define (prim.tupleSize x)
  4.   (vector-length x))
  5.  
  6. (define (prim.tupleSel tuple i n)
  7.  (force
  8.   (if (eqv? n 2)
  9.       (if (eqv? i 0)
  10.       (car tuple)
  11.       (cdr tuple))
  12.       (vector-ref tuple i))))
  13.  
  14. (define (prim.list->tuple l)
  15.   (let ((l (haskell-list->list/non-strict l)))
  16.     (if (null? (cddr l))
  17.     (cons (car l) (cadr l))
  18.     (list->vector l))))
  19.  
  20. (define (haskell-list->list/non-strict l)
  21.   (if (null? l)
  22.       '()
  23.       (cons (car l)
  24.         (haskell-list->list/non-strict (force (cdr l))))))
  25.  
  26. (define (prim.dict-sel dicts i)
  27.   (force (vector-ref dicts i)))
  28.  
  29. ;;; These generate dictionaries.
  30.  
  31. (define-local-syntax (create-dict dicts vars other-dicts)
  32.   `(let ((dict-vector (box (list->vector ,dicts))))
  33.      (make-tuple
  34.        ,@(map (lambda (v)
  35.         `(delay (funcall (force (dynamic ,v)) dict-vector)))
  36.        vars)
  37.        ,@(map (lambda (sd)
  38.         `(delay (,(car sd)
  39.              (map (lambda (d)
  40.                    (tuple-select ,(cadr sd) ,(caddr sd) (force d)))
  41.                   ,dicts))))
  42.           other-dicts))))
  43.  
  44. (define prim.tupleEqdict
  45.   (lambda dicts
  46.     (tupleEqDict/l dicts)))
  47.  
  48. (define (tupleEqDict/l dicts)
  49.   (create-dict dicts
  50.      (|PreludeTuple:tupleEq| |PreludeTuple:tupleNeq|)
  51.      ()))
  52.  
  53. (define prim.tupleOrdDict
  54.  (lambda dicts
  55.    (tupleOrdDict/l dicts)))
  56.  
  57. (define (tupleOrdDict/l d)
  58.   (create-dict d
  59.    (|PreludeTuple:tupleLe| |PreludeTuple:tupleLeq|
  60.     |PreludeTuple:tupleGeq| |PreludeTuple:tupleGe|
  61.     |PreludeTuple:tupleMax| |PreludeTuple:tupleMin|)
  62.    ((tupleEqDict/l 7 6))))
  63.  
  64. (define prim.tupleIxDict
  65.  (lambda dicts
  66.    (create-dict dicts
  67.       (|PreludeTuple:tupleRange| |PreludeTuple:tupleIndex|
  68.        |PreludeTuple:tupleInRange|)
  69.       ((tupleOrdDict/l 6 3) (tupleEqDict/l 6 4) (tupleTextDict/l 6 5)))))
  70.  
  71. (define prim.tupleTextDict
  72.  (lambda dicts
  73.    (tupleTextDict/l dicts)))
  74.  
  75. (define (tupleTextDict/l d)
  76.   (create-dict d
  77.      (|PreludeTuple:tupleReadsPrec| |PreludeTuple:tupleShowsPrec|
  78.       |PreludeTuple:tupleReadList| |PreludeTuple:tupleShowList|)
  79.      ()))
  80.  
  81. (define prim.tupleBinaryDict
  82.  (lambda dicts
  83.    (create-dict dicts
  84.     (|PreludeTuple:tupleReadBin| |PreludeTuple:tupleShowBin|)
  85.     ())))
  86.  
  87.